Unit BCommonUnit;

{$mode objfpc}{$H+}

Interface

Uses
  Classes, SysUtils, syncobjs, strutils, fgl, LiteLCLProc, BListsUnit;

Function I2S(Const aInteger: Integer): String; Inline;

Procedure Assert(Const aCondition: Boolean; Const aCode: Integer;
  Const aMessage: String); Inline;
Procedure Assert(Const aCondition: Boolean; Const aCode: Integer;
  Const aMessageMask: String; Const aParams: Array Of Const); Inline;

Function IndexOf(Const aString: String;Const aStrings: Array of String):Integer;

Procedure Log(Const aMessage: String);
Procedure Log(Const aMask: String; Const aParams: Array Of Const);

Procedure DirectLog(Const aMessage: String);

Procedure SafeLog(Const aMessage: String);

Function Ceil(Const aValue: Real): Integer;
Function Max(Const aValue1, aValue2: Integer): Integer;
Function Min(Const aValue1, aValue2: Integer): Integer;

Function DaysPerMonth(aYear, aMonth: Integer): Integer;

Function GetFirstDay(Const aDay: TDateTime): TDateTime;
Function GetLastDay(Const aDay: TDateTime): TDateTime;

Function GetFirstWeekDay(Const aDay: TDateTime): TDateTime;
Function GetLastWeekDay(Const aDay: TDateTime): TDateTime;

Procedure AppendCommaString(Var aString: String; Const aNewPart: String);
Procedure AppendCommaString(Var aString: String; Const aNewPartMask: String;
  Const aParams: Array Of Const);
Function GetCommaString(Const aArray: Array Of String): String;

//Deprecated
Function BuildIntegersList(Const aString: String;
  Const aSafe: Boolean = TRUE): BIntegersList;
Function BuildIntegersList(Const aArray: Array Of Integer): BIntegersList;
Procedure BuildIntegersList(Const aString: String; Const aResult: BIntegersList);

Procedure FillBStringsList(Const aString: String; Var aList: BStringsList);
Procedure FillBIntegersList(Const aString: String; Var aList: BIntegersList);
Procedure FillBDoublesList(Const aString: String; Const  aList: BDoublesList);
Procedure FillBDateTimesList(Const aString: String; Var aList: BDateTimesList);

Function ListAsString(Const aList: BIntegersList): String;
Function ListAsString(Const aList: BStringsList): String;

Type BErrorInfoRec = Packed Record
  Code: Integer;
  Message: String;
End;

Procedure BuildStringsList(Const aArray: Array Of String;
  Var aStringsList: BStringsList);
Function BuildStringsList(Const aArray: Array Of String): BStringsList;
Procedure BuildStringsList(aString: String; Var aStringsList: BStringsList);

Function Suppose(Const aCondition: Boolean; Const aCode: Integer;
  Const aMessage: String; Var aErrorInfo: BErrorInfoRec): Boolean; Inline;

Function FakeSuggest(Const aInput: BErrorInfoRec;
  Out aOutput: BErrorInfoRec): Boolean; Inline;
Function Suggest(Const aCondition: Boolean; Const aCode: Integer;
  Const aMessage: String): BErrorInfoRec; Inline;

Procedure CleanErrorInfo(Var aErrorInfo: BErrorInfoRec); Inline;
Function BuildErrorInfo(Const aCode: Integer;
  Const aMsg: String): BErrorInfoRec; Inline;

Type

{ BExceptionClass }

 BExceptionClass = Class(Exception)
  Private
    bCode: Integer;
    Function GetStackTrace: String;
  Public
    Property Code: Integer Read bCode;
    Property StackTrace: String Read GetStackTrace;
    Constructor Build(Const aCode: Integer; Const aMessage: String);
    Constructor Build(Const aCode: Integer; Const aMessageMask: String;
      Const aParams: Array Of Const);
    Constructor Build(Const aMessage: String);
    Constructor Build(Const aMessageMask: String;Const aParams: Array Of Const);
    Destructor Burn;
End;

Type

{ BParameterClass }

 BParameterClass = Class
  Private
    bInteger: Integer;
    bObject: TObject;
  Public
    Property ValueObject: TObject Read bObject;
    Property ValueInteger: Integer Read bInteger;
    Constructor SendObject(Const aObject: TObject);
    Constructor SendInteger(Const aInteger: Integer);
    Destructor Burn;
End;

Type BParametersList = Specialize TFPGList<BParameterClass>;

Var
  LogStream: TFileStream;
  NoLog: Boolean;
  HomeDir: String;

Implementation

Var
  aName: String;
  LogSection: TCriticalSection;

Function ExtractFileNameOnly(Const AFilename: string): string;
var
  StartPos: Integer;
  ExtPos: Integer;
begin
  StartPos:=length(AFilename)+1;
  while (StartPos>1)
  and (AFilename[StartPos-1]<>PathDelim)
  {$IFDEF Windows}and (AFilename[StartPos-1]<>':'){$ENDIF}
  do
    dec(StartPos);
  ExtPos:=length(AFilename);
  while (ExtPos>=StartPos) and (AFilename[ExtPos]<>'.') do
    dec(ExtPos);
  if (ExtPos<StartPos) then ExtPos:=length(AFilename)+1;
  Result:=copy(AFilename,StartPos,ExtPos-StartPos);
end;

Function ParamStrUTF8(Param: Integer): string;
Begin
  Result:=SysToUTF8(ObjPas.ParamStr(Param));
end;

Function I2S(Const aInteger: Integer): String;
Begin
  Str(aInteger, result);
end;

Procedure Assert(Const aCondition: Boolean; Const aCode: Integer;
  Const aMessage: String);
Begin
  If aCondition Then
    Raise BExceptionClass.Build(aCode, aMessage);
end;

Procedure Assert(Const aCondition: Boolean; Const aCode: Integer;
  Const aMessageMask: String; Const aParams: Array Of Const);
Begin
  Assert(aCondition, aCode, Format(aMessageMask, aParams));
end;

Function IndexOf(Const aString: String;Const aStrings: Array Of String):Integer;
Var
  i: Integer;
Begin
  Result := -1;
  For i := Low(aStrings) To High(aStrings) Do
    If aString = aStrings[i] Then Exit(i + 1);
end;

Procedure Log(Const aMessage: String);
Begin
  {$IFNDEF NoDirectLog}
  WriteLn(aMessage);
  {$ENDIF}
  If Not(NoLog) Then
    LogStream.WriteAnsiString(FormatDateTime('dd.mm.yy hh:mm:ss:zz', Now) +
      ':' + aMessage + #13#10);
end;

Procedure Log(Const aMask: String; Const aParams: Array Of Const);
Begin
  Log(Format(aMask, aParams));
end;

Procedure DirectLog(Const aMessage: String);
Begin
  LogSection.Enter;
  WriteLn(UTF8ToConsole(aMessage));
  LogSection.Leave;
end;

Procedure SafeLog(Const aMessage: String);
Begin
  LogSection.Enter;
  Log(aMessage);
  LogSection.Leave;
end;

Function Ceil(Const aValue: Real): Integer;
Begin
  If Trunc(aValue) - aValue = 0 Then
    Begin
      Result := Trunc(aValue);
      Exit;
    End;
  Result := Trunc(aValue) + 1;
end;

Function Max(Const aValue1, aValue2: Integer): Integer;
Begin
  Result := -1;
  If aValue1 > aValue2 Then Result := aValue1
  Else Result := aValue2;
end;

Function Min(Const aValue1, aValue2: Integer): Integer;
Begin
  Result := -1;
  If aValue1 < aValue2 Then Result := aValue1
  Else Result := aValue2;
end;

Function DaysPerMonth(aYear, aMonth: Integer): Integer;
Const
  DaysInMonth: array[1..12] of Integer = (31, 28, 31, 30, 31, 30, 31, 31, 30,
    31, 30, 31);
Begin
  Result := DaysInMonth[AMonth];
  If (aMonth = 2) And IsLeapYear(aYear) then Inc(Result);
End;


Function GetFirstDay(Const aDay: TDateTime): TDateTime;
Var
  Y, M, D: Word;
Begin
  DecodeDate(aDay, Y, M, D);
  D := 1;
  Result := EncodeDate(Y, M, D);
End;

Function GetLastDay(Const aDay: TDateTime): TDateTime;
Var
  Y, M, D: Word;
Begin
  DecodeDate(aDay, Y, M, D);
  D := DaysPerMonth(Y, M);
  Result := EncodeDate(Y, M, D);
End;

Function GetFirstWeekDay(Const aDay: TDateTime): TDateTime;
Begin
  Case DayOfWeek(aDay) Of
    1: Result := aDay - 6;
    2..7: Result := aDay - (DayOfWeek(aDay) - 2);
  End;
End;

Function GetLastWeekDay(Const aDay: TDateTime): TDateTime;
Begin
  Case DayOfWeek(aDay) Of
    1: Result := aDay;
    2..7: Result := aDay + (8 - DayOfWeek(aDay));
  End;
End;

Procedure AppendCommaString(Var aString: String; Const aNewPart: String);
Begin
  If Not(aString = '') Then aString += ',';
  aString += aNewPart;
end;

Procedure AppendCommaString(Var aString: String; Const aNewPartMask: String;
  Const aParams: Array Of Const);
Begin
  AppendCommaString(aString, Format(aNewPartMask, aParams));
end;

Function GetCommaString(Const aArray: Array Of String): String;
Var
  i: Integer;
Begin
  Result := '';
  For i := Low(aArray) To High(aArray) Do
    AppendCommaString(Result, aArray[i]);
end;

Function BuildIntegersList(Const aString: String;
  Const aSafe: Boolean): BIntegersList;
Var
  aIndex: Integer;
  aBuffer: String;
Begin
  Result := BIntegersList.Build;
  Try
    aBuffer := aString;
    While Not(aBuffer = '') Do
      Begin
        aIndex := Pos(',', aBuffer);
        If aIndex = 0 Then
          Begin
            If aSafe Then Result.Add(StrToIntDef(aBuffer, -1))
            Else Result.Add(StrToInt(aBuffer));
            aBuffer := '';
          End
        Else
          Begin
            If aSafe Then Result.Add(StrToIntDef(Copy(aBuffer, 1, aIndex-1), -1))
            Else Result.Add(StrToInt(Copy(aBuffer, 1, aIndex - 1)));
            Delete(aBuffer, 1, aIndex);
          End;
      End;
  Finally
    If Not(aBuffer = '') Then Result.Burn;
  End;
end;

Function BuildIntegersList(Const aArray: Array Of Integer): BIntegersList;
Var
  i: Integer;
Begin
  Result := BIntegersList.Create;
  For i := Low(aArray) To High(aArray) Do Result.Add(aArray[i]);
end;

Procedure BuildIntegersList(Const aString: String; Const aResult: BIntegersList);
Var
  aBuffer: String;
  aIndex: Integer;
Begin
  aResult.Clear;
  aBuffer := aString;
  While Not(aBuffer = '') Do
    Begin
      aIndex := Pos(',', aBuffer);
      If aIndex = 0 Then
        Begin
          aResult.Add(StrToIntDef(aBuffer, -1));
          aBuffer := '';
        End
      Else
        Begin
          aResult.Add(StrToIntDef(Copy(aBuffer, 1, aIndex - 1), -1));
          Delete(aBuffer, 1, aIndex);
        End;
    End;
end;

Procedure FillBStringsList(Const aString: String; Var aList: BStringsList);
Var
  aPrevPos: Integer;
  aPos: Integer = 1;
Begin
  aPrevPos := Pos('"', aString) + 1;
  While Not(aPos = 0) Do
    Begin
      aPos := PosEx('"', aString, aPrevPos);
      aList.Add(Copy(aString, aPrevPos, aPos - aPrevPos));
      aPrevPos := aPos + 3;
    End;
end;

Procedure FillBIntegersList(Const aString: String; Var aList: BIntegersList);
Var
  aPos: Integer = 1;
  aPrevPos: Integer = 1;
Begin
  While Not(aPos = 0) Do
    Begin
      aPos := PosEx(',', aString, aPrevPos);
      If aPos = 0 Then
        aList.Add(StrToInt(Copy(aString, aPrevPos, Length(aString)-aPrevPos+1 )))
      Else
        aList.Add(StrToInt(Copy(aString, aPrevPos, aPos - aPrevPos)));
      aPrevPos := aPos + 1;
    End;
end;

Procedure FillBDoublesList(Const aString: String; Const aList: BDoublesList);
Var
  aPos: Integer = 1;
  aPrevPos: Integer = 1;
  aSubString: String;
Begin
  While Not(aPos = 0) Do
    Begin
      aPos := PosEx(',', aString, aPrevPos);
      If aPos = 0 Then
        aSubString := Copy(aString, aPrevPos, Length(aString) - aPrevPos + 1)
      Else
        aSubString := Copy(aString, aPrevPos, aPos - aPrevPos);
      WriteLn('one: ', aSubString);
      WriteLn('two: ', StrToFloat(aSubString));
      aList.Add(StrToFloat(aSubString));
      WriteLn('three: ', aList[aList.Count - 1]);
      aPrevPos := aPos + 1;
    End;
end;

Procedure FillBDateTimesList(Const aString: String; Var aList: BDateTimesList);
Var
  i: Integer;
  aStringsList: BStringsList;
Begin
  aStringsList := BStringsList.Build;
  For i := 0 To aStringsList.Count - 1 Do
    aList.Add(StrToDateTime(aStringsList[i]));
  aStringsList.Burn;
end;

Function ListAsString(Const aList: BIntegersList): String;
Var
  i: Integer;
Begin
  Result := '';
  For i := 0 To aList.Count - 1 Do
    AppendCommaString(Result, Format('%d', [aList[i]]));
end;

Function ListAsString(Const aList: BStringsList): String;
Var
  i: Integer;
Begin
  Result := '';
  For i := 0 To aList.Count - 1 Do
    AppendCommaString(Result, Format('"%s"', [aList[i]]));
End;

Function ToString(Const aList: BIntegersList): String;
Var
  i: Integer;
Begin
  Result := '';
  For i := 0 To aList.Count - 1 Do
    AppendCommaString(Result, IntToStr(aList[i]));
end;

Procedure BuildStringsList(Const aArray: Array Of String;
  Var aStringsList: BStringsList);
Var
  i: Integer;
Begin
  For i := Low(aArray) To High(aArray) Do
    aStringsList.Add(aArray[i]);
end;

Function BuildStringsList(Const aArray: Array Of String): BStringsList;
Begin
  Result := BStringsList.Build;
  BuildStringsList(aArray, Result);
end;

Procedure BuildStringsList(aString: String; Var aStringsList: BStringsList);
Var
  aIndex: Integer;
Begin
  aIndex := Pos(',', aString);
  While Not(aIndex = 0) Do
    Begin
      aStringsList.Add(Copy(aString, 1, Pos(',', aString) - 1));
      Delete(aString, 1, aIndex);
      aIndex := Pos(',', aString);
    End;
  aStringsList.Add(aString);
end;

Function Suppose(Const aCondition: Boolean; Const aCode: Integer;
  Const aMessage: String; Var aErrorInfo: BErrorInfoRec): Boolean;
Begin
  Result := aCondition;
  If aCondition And (aErrorInfo.Code = 0) Then
    Begin
      aErrorInfo.Code := aCode;
      aErrorInfo.Message := aMessage;
    End;
end;

Function FakeSuggest(Const aInput: BErrorInfoRec; Out aOutput: BErrorInfoRec):Boolean;
Begin
  Result := Not(aInput.Code = 0);
  aOutput := aInput;
end;

Function Suggest(Const aCondition: Boolean; Const aCode: Integer;
  Const aMessage: String): BErrorInfoRec;
Begin
  Result.Code := 0;
  Result.Message := '';
  If aCondition Then
    Begin
      Result.Code := aCode;
      Result.Message := aMessage;
    End;
end;

Procedure CleanErrorInfo(Var aErrorInfo: BErrorInfoRec);
Begin
  aErrorInfo.Code := 0;
  aErrorInfo.Message := '';
end;

Function BuildErrorInfo(Const aCode: Integer; Const aMsg: String): BErrorInfoRec;
Begin
  Result.Code := aCode;
  If Result.Code = 0 Then Result.Code := -1;
  Result.Message := aMsg;
end;

Procedure SwapLists(Const aSource, aTarget: TList);
Var
  i: Integer;
Begin
  aTarget.Clear;
  For i := 0 To aSource.Count - 1 Do
    aTarget.Add(aSource[i]);
end;

Procedure SwapThreadLists(Const aSource, aTarget: TThreadList);
Begin
  SwapLists(aSource.LockList, aTarget.LockList);
  aTarget.UnlockList;
  aSource.UnlockList;
end;

Procedure CompareLists(Const aFirst, aSecond: TList; Out aSame, aNew,
  aOld: TList);
Begin
  aSame := TList.Create;
  aNew := TList.Create;
  aOld := TList.Create;
end;

{ BParameterClass }

Constructor BParameterClass.SendObject(Const aObject: TObject);
Begin
  bObject := aObject;
End;

Constructor BParameterClass.SendInteger(Const aInteger: Integer);
Begin
  bInteger := aInteger;
End;

Destructor BParameterClass.Burn;
Begin

End;

{ BExceptionClass }

Function BExceptionClass.GetStackTrace: String;
Var
  bp: Pointer;
  addr: Pointer;
  CurAddress: String;
  oldbp: Pointer;
Begin
  Result:='';
  { retrieve backtrace info }
  bp:=get_caller_frame(get_frame);
  while bp<>nil do begin
    addr:=get_caller_addr(bp);
    CurAddress:=BackTraceStrFunc(Addr);
    //DebugLn('GetStackTrace ',CurAddress);
    Result:=Result+CurAddress+LineEnding;
    oldbp:=bp;
    bp:=get_caller_frame(bp);
    if (bp<=oldbp) or (bp>(StackBottom + StackLength)) then
      bp:=nil;
  end;
end;

Constructor BExceptionClass.Build(Const aCode: Integer; Const aMessage: String);
Begin
  bCode := aCode;
  Inherited Message := aMessage;
End;

Constructor BExceptionClass.Build(Const aCode: Integer;
  Const aMessageMask: String; Const aParams: Array Of Const);
Begin
  bCode := aCode;
  Inherited Message := Format(aMessageMask, aParams);
End;

Constructor BExceptionClass.Build(Const aMessage: String);
Begin
  bCode := -1;
  Inherited Message := aMessage;
End;

Constructor BExceptionClass.Build(Const aMessageMask: String;
  Const aParams: Array Of Const);
Begin
  bCode := -1;
  Inherited Message := Format(aMessageMask, aParams);
End;

Destructor BExceptionClass.Burn;
Begin
End;

Initialization
Begin

  NoLog := FALSE;
  LogSection := TCriticalSection.Create;
  aName := ExtractFileNameOnly(ParamStrUTF8(0));
   
  If Not(DirectoryExists(GetUserDir + '.bdata')) Then
    mkdir(GetUserDir + '.bdata');
  HomeDir := GetUserDir + '.bdata' + DirectorySeparator;
  If Not(DirectoryExists(HomeDir + aName)) Then
    mkdir(HomeDir + aName);
  HomeDir := HomeDir + aName + DirectorySeparator;
  Try
    If FileExists(HomeDir + 'log.' +
      FormatDateTime('dd.mm.yy', Now) + '.txt') Then
      LogStream := TFileStream.Create(HomeDir + 'log.' +
        FormatDateTime('dd.mm.yy', Now) +'.txt', fmOpenWrite Or fmShareDenyNone)
    Else
      LogStream := TFileStream.Create(HomeDir + 'log.'  +
        FormatDateTime('dd.mm.yy', Now) + '.txt', fmCreate);
    LogStream.Seek(0, soEnd);
  Except
    NoLog := TRUE;
  End;
End;

Finalization
Begin
  LogStream.Free;
  LogSection.Free;
End;

End.